home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / tj50dsk1.zip / MISCTTT5.PAS < prev    next >
Pascal/Delphi Source File  |  1989-01-31  |  17KB  |  664 lines
  1. {--------------------------------------------------------------------------}
  2. {                         TechnoJock's Turbo Toolkit                       }
  3. {                                                                          }
  4. {                              Version   5.00                              }
  5. {                                                                          }
  6. {                                                                          }
  7. {              Copyright 1986, 1989 TechnoJock Software, Inc.              }
  8. {                           All Rights Reserved                            }
  9. {                          Restricted by License                           }
  10. {--------------------------------------------------------------------------}
  11.  
  12.                      {--------------------------------}                                       
  13.                      {       Unit:  MiscTTT5          }
  14.                      {--------------------------------}
  15.  
  16.  
  17. {$S-,R-,V-,D-}       
  18.  
  19. Unit MiscTTT5;
  20.  
  21. Interface
  22.  
  23. Uses CRT, DOS, FastTTT5, Strnttt5;
  24.  
  25. TYPE
  26.    Dates = word;   {change to longint for greater date ranges}
  27.  
  28. CONST
  29.    MMDDYY   = 1;   {Date formats}
  30.    MMDDYYYY = 2;
  31.    MMYY     = 3;
  32.    MMYYYY   = 4;
  33.    DDMMYY   = 5;
  34.    DDMMYYYY = 6;
  35.  
  36. VAR
  37.    ClockX,
  38.    ClockY,
  39.    ClockF,
  40.    ClockB : byte;
  41.  
  42. Function  Exist(Filename:string):boolean;
  43. Function  CopyFile(SourceFile, TargetFile:string): byte;
  44. Function  File_Size(Filename:string): longint;
  45. {$IFDEF VER50}
  46. Function  File_Drive(Full:string): string;
  47. Function  File_Directory(Full:string): string;
  48. Function  File_Name(Full:string): string;
  49. Function  File_Ext(Full:string): String;
  50. {$ENDIF}
  51. Function  Time: string;
  52. Procedure Clock;
  53. Function  Date: String;
  54. Procedure PrintScreen;
  55. Procedure Beep;
  56. function  Printer_Status:byte;
  57. Function  Printer_ready:boolean;
  58. Procedure FlushKeyBuffer;
  59. Procedure Reset_Printer;
  60. Function  DMY_to_String(D,M,Y:word;format:byte): string;
  61. Function  Date_To_Julian(InDate:string;format:byte): dates;
  62. Function  Julian_to_Date(J:dates;format:byte):string;
  63. Function  Today_in_Julian: dates;
  64. Function  Date_Within_Range(Min,Max,Test:dates):boolean;
  65. Function  Valid_Date(Indate:string;format:byte): boolean;
  66. Function  Future_Date(InDate:string;format:byte;Days:word): string;
  67. Function  Unformatted_date(InDate:string): string;
  68.  
  69. Implementation
  70.  
  71. Const
  72.     LastYearNextCentuary = 78;
  73.  
  74. Function Exist(Filename:string):boolean;
  75. {returns true if file exists}
  76. var Inf: SearchRec;
  77. begin
  78.     FindFirst(Filename,AnyFile,Inf);
  79.     Exist := (DOSError = 0);
  80. end;  {Func Exist}
  81.  
  82. Function CopyFile(SourceFile, TargetFile:string): byte;
  83. {return codes:  0 successful
  84.                 1 source and target the same
  85.                 2 cannot open source
  86.                 3 unable to create target
  87.                 4 error during copy
  88. }
  89. var
  90.   Source,
  91.   Target : file;
  92.   BRead,
  93.   Bwrite : word;
  94.   FileBuf  : array[1..2048] of char;
  95. begin
  96.     If SourceFile = TargetFile then
  97.     begin
  98.         CopyFile := 1;
  99.         exit;
  100.     end;
  101.     Assign(Source,SourceFile);
  102.     {$I-}
  103.     Reset(Source,1);
  104.     {$I+}
  105.     If IOResult <> 0 then
  106.     begin
  107.         CopyFile := 2;
  108.         exit;
  109.     end;
  110.     Assign(Target,TargetFile);
  111.     {$I-}
  112.     Rewrite(Target,1);
  113.     {$I+}
  114.     If IOResult <> 0 then
  115.     begin
  116.         CopyFile := 3;
  117.         exit;
  118.     end;
  119.     Repeat
  120.          BlockRead(Source,FileBuf,SizeOf(FileBuf),BRead);
  121.          BlockWrite(Target,FileBuf,Bread,Bwrite);
  122.     Until (Bread = 0) or (Bread <> BWrite);
  123.     Close(Source);
  124.     Close(Target);
  125.     If Bread <> Bwrite then
  126.        CopyFile := 4
  127.     else
  128.        CopyFile := 0;
  129. end; {of func CopyFile}
  130.  
  131.  Function File_Size(Filename:string): longint;
  132.  {returns  -1   if file not found}
  133.  var
  134.     F : file of byte;
  135.  begin
  136.      Assign(F,Filename);
  137.      {$I-}
  138.      Reset(F);
  139.      {$I+}
  140.      If IOResult <> 0 then
  141.      begin
  142.         File_Size := -1;
  143.         exit;
  144.      end;
  145.      File_Size := FileSize(F);
  146.      Close(F);
  147.  end; {of func File_Size}
  148.  
  149. {$IFDEF VER50}
  150.  Function File_Split(Part:byte;Full:string): string;
  151.  {used internally}
  152.  var
  153.     D : DirStr;
  154.     N : NameStr;
  155.     E : ExtStr;
  156.  begin
  157.      FSplit(Full,D,N,E);
  158.      Case Part of
  159.      1 : File_Split := D;
  160.      2 : File_Split := N;
  161.      3 : File_Split := E;
  162.      end;
  163.  end; {of func File_Split}
  164.  
  165.  Function File_Drive(Full:string): string;
  166.  {}
  167.  var
  168.    Temp : string;
  169.    P : byte;
  170.  begin
  171.      Temp := File_Split(1,Full);
  172.      P := Pos(':',Temp);
  173.      If P <> 2 then
  174.         File_Drive := ''
  175.      else
  176.         File_Drive := upcase(Temp[1]);
  177.  end; {of func File_Drive}
  178.  
  179.  Function File_Directory(Full:string): string;
  180.  {}
  181.  var
  182.    Temp : string;
  183.    P : byte;
  184.  begin
  185.      Temp := File_Split(1,Full);
  186.      P := Pos(':',Temp);
  187.      If P = 2 then
  188.         Delete(Temp,1,2);                 {remove drive}
  189.      If (Temp[length(Temp)]  ='\') and (temp <> '\') then
  190.         Delete(temp,length(Temp),1);      {remove last backslash}
  191.      File_Directory := Temp;
  192.  end; {of func File_Directory}
  193.  
  194.  Function File_Name(Full:string): string;
  195.  {}
  196.  begin
  197.      File_Name := File_Split(2,Full);
  198.  end; {of func File_Name}
  199.  
  200.  Function File_Ext(Full:string): String;
  201.  {}
  202.  var
  203.    Temp : string;
  204.  begin
  205.      Temp := File_Split(3,Full);
  206.      If (Temp = '') or (Temp = '.') then
  207.         File_Ext := temp
  208.      else
  209.         File_Ext := copy(Temp,2,3);
  210.  end; {of func File_Ext}
  211. {$ENDIF}
  212. function time: string;
  213. var
  214.   hour,min,sec:     string[2];
  215.   H,M,S,T : word;
  216. begin
  217.     GetTime(H,M,S,T);
  218.     Str(H,Hour);
  219.     Str(M,Min);
  220.     Str(S,Sec);
  221.     if S < 10 then            {pad a leading zero if sec is < 10 }
  222.       sec := '0'+sec;
  223.     if M < 10 then            {pad a leading zero if min is < 10 }
  224.         min := '0'+min;
  225.     if H > 12 then           { assign an a.m. or p.m. string }
  226.     begin
  227.        str(H - 12,hour);
  228.        IF length(hour) = 1 then Hour := ' '+hour;
  229.           time := hour+':'+min+':'+sec+' p.m.'
  230.     end
  231.     else
  232.        time := hour+':'+min+':'+sec+' a.m.';
  233.     if H = 12 then
  234.        time := hour+':'+min+':'+sec+' p.m.';
  235. end;
  236.  
  237. {$F+}
  238. Procedure Clock;
  239. {}
  240. begin
  241.     Fastwrite(ClockX,ClockY,attr(ClockF,ClockB),Time);
  242. end; {of proc Clock}
  243. {$F-}
  244.  
  245. function Date: String;
  246. type
  247.   WeekDays = array[0..6]  of string[9];
  248.   Months   = array[1..12] of string[9];
  249. const
  250.     DayNames   : WeekDays  = ('Sunday','Monday','Tuesday','Wednesday',
  251.                               'Thursday','Friday','Saturday');
  252.     MonthNames : Months    = ('January','February','March','April','May',
  253.                               'June','July','August','September',
  254.                               'October','November','December');
  255. var
  256.  Y,
  257.  M,
  258.  D,
  259.  DayOfWeek : word;
  260.  Year   : string;
  261.  Day    : string;
  262. begin
  263.     GetDate(Y,M,D,DayofWeek);
  264.     Str(Y,Year);
  265.     Str(D,Day);
  266.     Date := DayNames[DayOfWeek]+' '+MonthNames[M]+' '+Day+', '+Year;
  267. end;
  268.  
  269. Procedure PrintScreen;
  270. var Regpack : registers;
  271. begin
  272.     intr($05,regpack);
  273. end;
  274.  
  275. procedure Beep;
  276. begin
  277.     sound(800);Delay(150);
  278.     sound(600);Delay(100);
  279.     Nosound;
  280. end;
  281.  
  282. function Printer_Status:byte;
  283. {Credits: Robert W. Lewis, VA thanks! Special masking employed for non-
  284.           standard printers, e.g. daisy wheels!!! }
  285. var Recpack : registers;
  286. begin
  287.     with recpack do
  288.     begin
  289.         Ah := 2;
  290.         Dx := 0;
  291.         intr($17,recpack);
  292.         If (Ah and $B8) = $90 then
  293.            Printer_Status := 0           {all's well}
  294.         else
  295.            If (Ah and $20) = $20 then
  296.               Printer_Status := 1        {no Paper}
  297.         else
  298.            If (Ah and $10) = $00 then
  299.               Printer_Status := 2        {off line}
  300.         else
  301.            If (Ah and $80) = $00 then
  302.               Printer_Status := 3        {busy}
  303.         else
  304.            If (Ah and $08) = $08 then
  305.               Printer_Status := 4;       {undetermined error}
  306.     end;
  307. end;
  308.  
  309. function printer_ready :boolean;
  310. begin
  311.     Printer_ready := (Printer_Status = 0);
  312. end;
  313.  
  314. Procedure FlushKeyBuffer;
  315. var Recpack : registers;
  316. begin
  317.     with recpack do
  318.     begin
  319.         Ax := ($0c shl 8) or 6;
  320.         Dx := $00ff;
  321.     end;
  322.     Intr($21,recpack);
  323. end;
  324.  
  325. Procedure Reset_Printer;
  326. var address: integer absolute $0040:$0008;
  327.              portno,delay : integer;
  328. begin
  329.     portno := address + 2;
  330.     port[portno] := 232;
  331.     for delay := 1 to 2000 do {nothing};
  332.     port[portno] := 236;
  333. end;
  334.  
  335. {++++++++++++++++++++++++++++++++++}
  336. {                                  }
  337. {    D A T E    R O U T I N E S    }
  338. {                                  }
  339. {++++++++++++++++++++++++++++++++++}
  340.  
  341. (*
  342.  Note that the Julian date logic applied in these routines is that day 1 is
  343.  January 1, 1900. All subsequent dates are represented by the number of
  344.  days elapsed since day 1. The INTERFACE section includes a declaration of
  345.  type DATES - this is set equal to type word, but it could be changed to
  346.  type longint to provide a much greater date range. 
  347.  
  348.  Throughout these procedures and functions a date "format" must be passed. The
  349.  format codes are:
  350.  
  351.                   1  MM/DD/YY
  352.                   2  MM/DD/YYYY
  353.                   3  MM/YY
  354.                   4  MM/YYYY
  355.                   5  DD/MM/YY {International format}
  356.                   6  DD/MM/YYYY   {   "    }
  357.  
  358.  When passing dates in string form the "separators" are not significant. For
  359.  example, the following strings are all treated alike:
  360.  
  361.                      120188
  362.                      12/01/88
  363.                      12-01-88
  364.                      12-01/88
  365.                      12----01----88
  366.  Only the numerical digits are significant, the alphas are ignored.
  367.  
  368. *)
  369.   Function Nth_Number(InStr:string;Nth:byte) : char;
  370.   {Returns the nth number in an alphanumeric string}
  371.   var
  372.      Counter : byte;
  373.      B, Len : byte;
  374.   begin
  375.       Counter := 0;
  376.       B := 0;
  377.       Len := Length(InStr);
  378.       Repeat
  379.            Inc(B);
  380.            If InStr[B] in ['0'..'9'] then
  381.               Inc(Counter);
  382.       Until (Counter = Nth) or (B >= Len);
  383.       If (Counter >= Len) and ( (InStr[Len] in ['0'..'9']) = false) then
  384.          Nth_Number := #0
  385.       else
  386.          Nth_Number := InStr[B];
  387.   end; {of func Nth_Number}
  388.  
  389.  Function Day(DStr:string;Format:byte): word;
  390.  {INTERNAL}
  391.  var
  392.     DayStr: string;
  393.  begin
  394.      Case Format of
  395.      MMDDYY,
  396.      MMDDYYYY :  DayStr := Nth_Number(DStr,3)+Nth_Number(DStr,4);
  397.      DDMMYY,
  398.      DDMMYYYY :  DayStr := Nth_Number(DStr,1)+Nth_Number(DStr,2);
  399.      else     DayStr := '01';
  400.      end;
  401.      Day := Str_To_Int(DayStr);
  402.  end; {of func Day}
  403.  
  404.  Function Month(DStr:string;Format:byte): word;
  405.  {INTERNAL}
  406.  var
  407.     MonStr: string;
  408.  begin
  409.      Case Format of
  410.      MMDDYY,
  411.      MMDDYYYY,
  412.      MMYY,
  413.      MMYYYY    :  MonStr := Nth_Number(DStr,1)+Nth_Number(DStr,2);
  414.      DDMMYY,
  415.      DDMMYYYY  :  MonStr := Nth_Number(DStr,3)+Nth_Number(DStr,4);
  416.      end;
  417.      Month := Str_To_Int(MonStr);
  418.  end; {of func Month}
  419.  
  420.  Function Year(DStr:string;Format:byte): word;
  421.  {INTERNAL}
  422.  var
  423.     YrStr   : string;
  424.     TmpYr   : word;
  425.  begin
  426.      Case Format of
  427.      MMDDYY,
  428.      DDMMYY   :  YrStr := Nth_Number(DStr,5)+Nth_Number(DStr,6);
  429.      MMDDYYYY,
  430.      DDMMYYYY :  YrStr := Nth_Number(DStr,5)+Nth_Number(DStr,6)+
  431.                      Nth_Number(DStr,7)+Nth_Number(DStr,8);
  432.      MMYY     :  YrStr := Nth_Number(DStr,3)+Nth_Number(DStr,4);
  433.      MMYYYY   :  YrStr := Nth_Number(DStr,3)+Nth_Number(DStr,4)+
  434.                      Nth_Number(DStr,5)+Nth_Number(DStr,6);
  435.      end;
  436.      TmpYr := Str_To_Int(YrStr);
  437.      If TmpYr < LastYearNextCentuary then
  438.         TmpYr := 2000 + TmpYr
  439.      else
  440.         If Tmpyr < 1000 then
  441.            TmpYr := 1900 + TmpYr;
  442.      Year := TmpYr;
  443.  end; {of func Year}
  444.  
  445.  Function DMY_to_String(D,M,Y:word;format:byte): string;
  446.  {INTERNAL}
  447.  const
  448.      PadChar = '/';
  449.  var
  450.     DD,MM,YY : string[4];
  451.  begin
  452.      DD := Int_to_Str(D);
  453.      If D < 10 then
  454.         DD := '0'+DD;
  455.      MM := Int_to_Str(M);
  456.      If M < 10 then
  457.         MM := '0'+MM;
  458.      If Format in [MMDDYY,MMYY,DDMMYY] then
  459.      begin
  460.          If Y > 99 then
  461.             If Y > 2000 then
  462.                Y := Y - 2000
  463.             else
  464.                If Y > 1900 then
  465.                   Y := Y - 1900
  466.                else
  467.                   Y := Y Mod 100;
  468.      end
  469.      else
  470.      begin
  471.          If Y < 1900 then
  472.             If Y < LastYearNextCentuary then
  473.                Y := Y + 2000
  474.             else
  475.                Y := Y + 1900;
  476.      end;
  477.      YY := Int_to_Str(Y);
  478.      If Y < 10 then
  479.         YY := '0'+YY;
  480.      Case Format of
  481.      MMDDYY,
  482.      MMDDYYYY: DMY_to_String := MM+PadChar+DD+Padchar+YY;
  483.      MMYY,
  484.      MMYYYY  : DMY_to_String := MM+Padchar+YY;
  485.      DDMMYY,
  486.      DDMMYYYY: DMY_to_String := DD+PadChar+MM+Padchar+YY;
  487.      end; {case}
  488.  end; {of func DMY_to_String}
  489.  
  490.  Function Date_To_Julian(InDate:string;format:byte): dates;
  491.  {Does not check the date is valid. Passed a date string and
  492.   returns a julian date}
  493.  var
  494.     D,M,Y :  word;
  495.     Temp : dates;
  496.  begin
  497.      D := Day(Indate,format);
  498.      M := Month(Indate,format);
  499.      Y := Year(Indate,format);
  500.      If  (Y=1900)
  501.      and (M <= 2) then
  502.      begin
  503.          If M = 1 then
  504.             Temp := pred(D)
  505.          else
  506.             Temp := D+30;
  507.      end
  508.      else
  509.      begin
  510.          If M > 2 then
  511.             M := M - 3
  512.          else
  513.          begin
  514.              M := M + 9;
  515.              dec(Y);
  516.          end;
  517.          Y := Y - 1900;
  518.          Temp := (1461*longint(Y) div 4) +
  519.                  (153*M+2) div 5 +
  520.                  D + 58;
  521.      end;
  522.      Date_to_Julian := Temp;
  523.  end; {of func Date_To_Julian}
  524.  
  525.  Function Julian_to_Date(J:dates;format:byte):string;
  526.  {}
  527.  var
  528.     D,M,Y : word;
  529.     Remainder,Factored : longint;
  530.  begin
  531.      If J = 0 then
  532.      begin
  533.          Case Format of
  534.          DDMMYY,MMDDYY :   Julian_to_date := '  /  /  ';
  535.          DDMMYYYY,MMDDYYYY:Julian_to_date := '  /  /    ';
  536.          MMYYYY:           Julian_to_Date := '  /    ';
  537.          else              Julian_to_date := '  /  ';
  538.          end;
  539.          exit;
  540.      end;
  541.      If J <= 58 then
  542.      begin
  543.          Y := 1900;
  544.          If J <= 30 then
  545.          begin
  546.              M := 1;
  547.              D := succ(J);
  548.          end
  549.          else
  550.          begin
  551.              M := 2;
  552.              D := J - 30;
  553.          end;
  554.      end
  555.      else
  556.      begin
  557.          Factored := 4*LongInt(J) - 233;
  558.          Y := Factored div 1461;
  559.          Remainder := (Factored mod 1461 div 4 * 5) + 2;
  560.          M := Remainder div 153;
  561.          D := succ((Remainder mod 153) div 5);
  562.          Y := Y + 1900;
  563.          If M < 10 then
  564.             M := M + 3
  565.          else
  566.          begin
  567.              M := M - 9;
  568.              Inc(Y);
  569.          end;
  570.      end;
  571.      Julian_to_date := DMY_to_String(D,M,Y,format);
  572.  end; {of proc Julian_to_Date}
  573.  
  574.  Function Date_Within_Range(Min,Max,Test:dates):boolean;
  575.  {}
  576.  begin
  577.      Date_Within_Range := ((Test >= Min) and (Test <= Max));
  578.  end; {of func Date_Within_Range}
  579.  
  580.  Function Valid_Date(Indate:string;format:byte): boolean;
  581.  {}
  582.  var
  583.    D,M,Y : word;
  584.    OK : Boolean;
  585.  begin
  586.      OK := true;  {positive thinking!}
  587.      If format in [MMYY,MMYYYY] then
  588.         D := 1
  589.      else
  590.         D := Day(Indate,format);
  591.      M := Month(Indate,format);
  592.      Y := Year(Indate,format);
  593.      If (D < 1)
  594.      or (D > 31)
  595.      or (M < 1)
  596.      or (M > 12)
  597.      or ((Y > 99) and (Y < 1900))
  598.      or (Y > 2078)
  599.      then 
  600.         OK := False
  601.      else
  602.         Case M of
  603.         4,6,9,11:         OK :=   (D <= 30);
  604.         2:                OK :=   (D <= 28)
  605.                                or (
  606.                                         (D = 29) 
  607.                                     and (Y <> 1900) 
  608.                                     and (Y <> 0)
  609.                                     and (Y mod 4 = 0)
  610.                                   )
  611.         end; {case}
  612.      Valid_Date := OK;
  613.  end; {of func Valid_Date}
  614.  
  615.  Function Today_in_Julian: dates;
  616.  {}
  617.  var
  618.  Y,
  619.  M,
  620.  D,
  621.  DayOfWeek : word;
  622.  Year   : string;
  623.  Day    : string;
  624.  begin
  625.      GetDate(Y,M,D,DayofWeek);
  626.      Today_in_Julian := Date_to_Julian(DMY_to_String(D,M,Y,1),1);
  627.  end; {of func Today_in_Julian}
  628.  
  629.  Function Future_Date(InDate:string;format:byte;Days:word): string;
  630.  {}
  631.  var J : dates;
  632.  begin
  633.      Future_date := Julian_to_date(Date_to_Julian(InDate,Format)+Days,Format);
  634.  end; {of func Future_Date}
  635.  
  636.  Function Unformatted_date(InDate:string): string;
  637.  {strips all non numeric characters}
  638.  var I : Integer;
  639.  
  640.            Function digit(C:char): boolean;
  641.            {}
  642.            begin
  643.                Digit := C in ['0'..'9'];
  644.            end; {of func digit}
  645.  
  646.  begin
  647.      I := 1;
  648.      Repeat
  649.           If (digit(Indate[I]) = false) and (length(Indate) > 0) then
  650.              Delete(Indate,I,1)
  651.           else
  652.              I := succ(I);
  653.      Until (I > length(Indate)) or (Indate = '');
  654.      Unformatted_Date := Indate;
  655.  end; {of func Unformatted_date}
  656.  
  657.  
  658. begin
  659.     ClockX := 67;
  660.     ClockY := 1;
  661.     ClockF := white;
  662.     ClockB := black;
  663. end.
  664.